home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #2
/
Monster Media No. 2 (Monster Media)(1994).ISO
/
prog_gen
/
qshade.zip
/
DRAWPOLY.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-06-04
|
4KB
|
179 lines
(*
──────────────────────
Fill Poly unit v1.1
──────────────────────
(c)1994 Rsc Research
Write me at: or on Compuserve
──────────── ────────────────
Cédric Rime 100340,2736
Dixence 21
1950 Sion
Switzerland
This program is entered as Shareware.
If you find it useful, a small donation would be appreciated.(then i can take some English lessons!!!)
Feel free to incorporate the code into your own programs.
*)
{$F-}{$N+}{$E+}{$D-}{$L-}{$Y-}
UNIT DrawPoly;
INTERFACE
USES crt;
TYPE PT=RECORD x,y:LongInt;END; (*Point Type X,Y*)
tTRI =ARRAY[1..3] OF pt;
TYPE Pvs=^tvs;
tVS=ARRAY[0..199,0..319] OF BYTE; (*Virtual Display*)
VAR VS:Pvs;
CONST SIF=64; (*Don't change!!!*)
PROCEDURE Point(x,y:INTEGER;co:BYTE); (*Draw a point*)
PROCEDURE Quad(p:ARRAY OF pt;co:BYTE); (*Draw 4 sides polygon*)
PROCEDURE Tri(P:ARRAY OF pt;co:BYTE); (*Draw 3 sides "*)
PROCEDURE vscls; (*Clear display*)
PROCEDURE vsShow; (*Show display*)
PROCEDURE vsInit; (*Init Display*)
PROCEDURE vsDone; (*Restore Display*)
PROCEDURE SetRGB(co,r,g,b:BYTE);
IMPLEMENTATION
PROCEDURE SetRGB(co,r,g,b:BYTE);
BEGIN
Port[$3C8] := Co;
Port[$3C9] := R;
Port[$3C9] := G;
Port[$3C9] := B;
END;
PROCEDURE vsInit;
VAR q:BYTE;
BEGIN
GetMem(vs,SizeOf(tvs)+1024);
IF vs=NIL THEN BEGIN WriteLn;WriteLn('Not enough memory');HALT;END;
asm
mov ax,$0013
Int $10
END;
FOR q:=1 TO 255 DO setrgb(q,q SHR 2,0,q DIV 10);
END;
PROCEDURE vsDone;
BEGIN
TextMode(lastmode);
FreeMem(vs,SizeOf(tvs)+1024);
END;
PROCEDURE vscls;
BEGIN
FillChar(vs^[0,0],SizeOf(Tvs),0);
END;
PROCEDURE vsShow;
BEGIN
Move(vs^[0,0],mem[segA000:0],SizeOf(tvs));
END;
PROCEDURE Point(x,y:INTEGER;co:BYTE);
BEGIN
IF (x<=319) AND (x>=0) AND (y<=199) AND (y>=0) THEN
vs^[y,x]:=co;
END;
PROCEDURE Tri(P:ARRAY OF pt;co:BYTE);
VAR q,w:INTEGER;
S:pt;
f12,f13,f23:LongInt;
s1,s2:LongInt;
PROCEDURE Hline(s1,s2:LongInt;y:INTEGER;co:BYTE);
VAR x1,x2:INTEGER;
q:INTEGER;
BEGIN
x1:=s1 DIV SIF;
x2:=s2 DIV SIF;
IF x1>x2 THEN BEGIN q:=x1;x1:=x2;x2:=q;END;
IF x1<0 THEN x1:=0;
IF x2<0 THEN EXIT;
IF x1>319 THEN EXIT;
IF x2>319 THEN x2:=319;
IF y<0 THEN EXIT;
IF y>199 THEN EXIT;
FOR q:=x1 TO x2 DO IF vs^[y,q]=0 THEN vs^[y,q]:=co;
END;
BEGIN
IF p[0].y>p[2].y THEN BEGIN s:=p[0];p[0]:=p[2];p[2]:=s;END;
IF p[0].y>p[1].y THEN BEGIN s:=p[0];p[0]:=p[1];p[1]:=s;END;
IF p[1].y>p[2].y THEN BEGIN s:=p[1];p[1]:=p[2];p[2]:=s;END;
q:=(p[0].y-p[1].y);
IF q<>0 THEN f12:=LongInt((p[0].x-p[1].x) * SIF) DIV q ELSE f12:=0;
q:=(p[0].y-p[2].y);
IF q<>0 THEN f13:=LongInt((p[0].x-p[2].x) * SIF) DIV q ELSE f13:=0;
q:=(p[1].y-p[2].y);
IF q<>0 THEN f23:=LongInt((p[1].x-p[2].x) * SIF) DIV q ELSE f23:=0;
(*
gotoxy(p[0].x div 8,p[0].y div 8);write('1');
gotoxy(p[1].x div 8,p[1].y div 8);write('2');
gotoxy(p[2].x div 8,p[2].y div 8);write('3');
*)
s1:=p[0].x*SIF;s2:=s1;
FOR q:=p[0].y TO p[1].y DO
BEGIN
Hline(s1,s2,q,co);
s1:=s1+f12;
s2:=s2+f13;
END;
s1:=p[2].x*SIF;s2:=s1;
FOR q:=p[2].y DOWNTO p[1].y DO
BEGIN
Hline(s1,s2,q,co);
s1:=s1-f23;
s2:=s2-f13;
END;
END;
(*#############################################################
###############################################################
###############################################################
#############################################################*)
PROCEDURE Quad(p:ARRAY OF pt;co:BYTE);
VAR t1,t2:ARRAY[1..3] OF pt;
BEGIN
t1[1]:=p[0];
t1[2]:=p[1];
t1[3]:=p[2];
t2[1]:=p[0];
t2[2]:=p[2];
t2[3]:=p[3];
tri(t1,co);
tri(t2,co);
END;
(*#############################################################
###############################################################
###############################################################
#############################################################*)
BEGIN
END.